home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Over 1,000 Windows 95 Programs
/
Over 1000 Windows 95 Programs (Microforum) (Disc 1).iso
/
1138
/
source.zip
/
PAPERBOY.BAS
< prev
next >
Wrap
BASIC Source File
|
1995-05-15
|
17KB
|
494 lines
Option Explicit
' Global variables
Global PaperboyVersion As String
Global INIfile As String
Global Group As Integer
Global Message As Integer
Global mailsendto As String
Global mailsubject As String
Global mailreferences As String
Global replytype As Integer '1=mail, 2=news
Global Persist As Integer 'Remember position from previous packet
' Windows API used by program
Declare Function GetWinFlags Lib "Kernel" () As Long
Global Const WF_CPU286 = &H2
Declare Function GetProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%)
Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
Declare Function WriteProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpString$)
Declare Function GetPrivateProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFileName$)
Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpreturned$, ByVal nSize%, ByVal lpFileName$)
Declare Function WritePrivateProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpString$, ByVal lpFileName$)
Declare Function lstrcpy Lib "Kernel" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function GetModuleUsage% Lib "Kernel" (ByVal hModule%)
' Paperboy/SOUP support DLL API
Global Const ERRMEM = 10
Global Const ERRIO = 20
Global Const ERRPARSE = 30
Global Const NUMFOLDERS = 20
Type finder
Group As Integer
Message As Integer
lineno As Integer
End Type
Declare Function InitSOUPDLL% Lib "PBOYSOUP.DLL" ()
Declare Function MajorVersion% Lib "PBOYSOUP.DLL" ()
Declare Function MinorVersion% Lib "PBOYSOUP.DLL" ()
Declare Function VersionDesc Lib "PBOYSOUP.DLL" () As Long
Declare Function LoadAreas Lib "PBOYSOUP.DLL" (ByVal fname As String) As Integer
Declare Function GetNumAreas Lib "PBOYSOUP.DLL" () As Integer
Declare Function GetAreaName Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetAreaEncoding Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetAreaDesc Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Long
Declare Function GetNumMsgs Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function ThreadMsgs Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function GetSubject Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetLength Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetAuthor Lib "PBOYSOUP.DLL" (ByVal index As Integer, ByVal index2 As Integer) As Long
Declare Function GetNumLines Lib "PBOYSOUP.DLL" () As Integer
Declare Function GetLine Lib "PBOYSOUP.DLL" (ByVal lineno As Integer) As Long
Declare Function GetInfo Lib "PBOYSOUP.DLL" () As Integer
Declare Function Post Lib "PBOYSOUP.DLL" (ByVal fname As String, ByVal sendtype As Integer) As Integer
Declare Function GetHeader Lib "PBOYSOUP.DLL" (ByVal header As String) As Long
Declare Function GetGMTime Lib "PBOYSOUP.DLL" () As Long
Declare Sub GetMsg Lib "PBOYSOUP.DLL" (ByVal index1 As Integer, ByVal index2 As Integer)
Declare Sub Rot13Msg Lib "PBOYSOUP.DLL" ()
Declare Sub reclaimareas Lib "PBOYSOUP.DLL" ()
Declare Function IsFolder Lib "PBOYSOUP.DLL" (ByVal index As Integer) As Integer
Declare Function LoadFolder Lib "PBOYSOUP.DLL" (ByVal foldername As String, ByVal folderfile As String, ByVal folderdesc As String) As Integer
Declare Sub CreateNewMsg Lib "PBOYSOUP.DLL" ()
Declare Function AddLineToMsg Lib "PBOYSOUP.DLL" (ByVal newline As String) As Integer
Declare Sub RemoveArea Lib "PBOYSOUP.DLL" (ByVal foldername As String)
Declare Function SaveMsgToFolder Lib "PBOYSOUP.DLL" (ByVal filename As String) As Integer
Declare Function DeleteMsg Lib "PBOYSOUP.DLL" (ByVal areaindex As Integer, ByVal msgindex As Integer) As Integer
Declare Function Find Lib "PBOYSOUP.DLL" (begin As finder, ByVal srchstring As String) As Integer
Declare Function GetErrorText Lib "PBOYSOUP.DLL" () As Long
Sub CheckCPU ()
Dim cputype As Long
' Check for CPU > 286
cputype = GetWinFlags()
If cputype And WF_CPU286 Then
' Paperboy DLL uses 386 instructions, warn user now
MsgBox "Paperboy requires a 386SX or greater processor.", MB_OK + MB_ICONSTOP, "Warning!"
End
End If
End Sub
Sub CreateFolder (foldername As String)
Dim folderfile As String
Dim filenum As Integer
Dim foldernum As Integer
If foldername = "" Then Exit Sub
' See if folder already exists
For foldernum = 1 To NUMFOLDERS
If GetINI("Folders", "Name" + Format$(foldernum), "") = foldername Then
Exit Sub
End If
Next foldernum
foldernum = 1
' Find a blank folder slot
screen.MousePointer = HourGlass
frmmain.lstsubjects.Enabled = False
foldernum = 1
While GetINI("Folders", "Name" + Format$(foldernum), "") <> ""
foldernum = foldernum + 1
Wend
If foldernum > NUMFOLDERS Then
MsgBox "Too many folders", 0, "Warning!"
Else
' Create the folder
SetINI "Folders", "Name" + Format$(foldernum), foldername
' Create folder file
folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
filenum = FreeFile
Open folderfile For Append As filenum
Close filenum
End If
' Reread folders
DoFolders
End Sub
Sub DllErr (ByVal result As Integer)
Dim continue As Integer
Dim msgstr As String
msgstr = fixstr(GetErrorText())
If result > 0 And result < 100 Then
If result = ERRMEM Then
continue = MsgBox(msgstr + Chr$(10) + "Restart to assure reliable operation" + Chr(10) + "Continue?", MB_YESNO + MB_DEFBUTTON1 + MB_ICONSTOP, "PBOYSOUP.DLL: Out of Memory")
End If
If result = ERRIO Then
continue = MsgBox(msgstr + Chr$(10) + "Reliability may suffer, continue?", MB_YESNO + MB_DEFBUTTON2 + MB_ICONSTOP, "PBOYSOUP.DLL: File format error")
End If
If result = ERRPARSE Then
continue = MsgBox(msgstr + Chr$(10) + "Reliability may suffer, continue?", MB_YESNO + MB_DEFBUTTON2 + MB_ICONSTOP, "PBOYSOUP.DLL: Incompatible file format")
End If
If continue = IDNO Then
frmmain.Hide ' This should end sub main
End If
End If
End Sub
Sub DoFolders ()
Dim foldernum As Integer
Dim foldername As String
Dim folderfile As String
Dim result As Integer
screen.MousePointer = HourGlass
For foldernum = 1 To NUMFOLDERS
foldername = GetINI("Folders", "Name" + Format$(foldernum), "")
If foldername <> "" Then
folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
result = LoadFolder(foldername, folderfile, "Paperboy folder")
DllErr result
End If
Next foldernum
Call ShowAreas
screen.MousePointer = default
End Sub
Function endofheaders ()
Dim firstline As Integer
'Skip headers
firstline = 1
While firstline < GetNumLines() And Len(fixstr(GetLine(firstline))) > 0
firstline = firstline + 1
Wend
'Skip the gap
While firstline < GetNumLines() And Len(fixstr(GetLine(firstline))) = 0
firstline = firstline + 1
Wend
endofheaders = firstline
End Function
Function extractusername (from As String) As String
Dim username As String
Dim pos As Integer
username = Trim(from) 'Remove leading and trailing spaces
' First type is of foo@bad.edu (john q. public)
If InStr(username, "(") > 0 Then
pos = InStr(username, "(")
' Remove everything before (, up to )
username = Mid$(username, pos + 1)
username = Left$(username, InStr(username, ")") - 1)
ElseIf InStr(username, Chr(34)) > 0 Then
' foo@bad.edu "john q. public"
pos = InStr(username, Chr(34))
username = Mid$(username, pos)
' Truncate past second quote
username = Left$(username, InStr(username, Chr(34)) - 1)
ElseIf InStr(username, "<") > 0 Then
' John Q. Public <foo@bad.edu>
pos = InStr(username, "<")
username = Left$(username, pos - 1)
ElseIf InStr(username, "@") > 0 Then
' worst-case, john@bad.edu
pos = InStr(username, "@")
username = Left$(username, pos - 1)
End If
' If parsing gave us nothing, punt
username = Trim(username)
If Len(username) = 0 Then username = from
extractusername = username
End Function
Function FileExists (fname As String) As Integer
'Dim fout As Integer
'fout = FreeFile
'On Error Resume Next
'Open fname For Input As fout
'If Err = 0 Then
'Close fout
'FileExists = 1
'Else
'FileExists = 0
'End If
If Dir$(fname) = "" Then FileExists = 0 Else FileExists = -1
End Function
Function fixstr (ByVal az As Long) As String
Static tempstr As String * 1000
Dim z As Integer
If az <> 0 Then
az = lstrcpy(tempstr, az)
z = InStr(tempstr, Chr(0)) 'Chop off null-terminator
If z > 0 Then fixstr = Left$(tempstr, z - 1) Else fixstr = tempstr
Else fixstr = ""
End If
End Function
Function GetINI (ByVal section As String, ByVal key As String, ByVal defvalue As String) As String
Dim result As Integer
Dim newvalue As String
Static hold As String * 200 'Holding place for returned string
result = GetPrivateProfileString(section, key, "xYzZy", hold, 199, INIfile)
'Chop off null-terminator
result = InStr(hold, Chr(0))
If result > 0 Then newvalue = Left$(hold, result - 1) Else newvalue = hold
If newvalue = "xYzZy" Then
' Write default out to INI file so user knows what's going on
result = WritePrivateProfileString(section, key, defvalue, INIfile)
newvalue = defvalue
End If
While Left$(newvalue, 1) = " "
newvalue = Mid$(newvalue, 2) 'Remove trailing spaces
Wend
GetINI = newvalue
End Function
Function intmax (ByVal a As Integer, ByVal b As Integer) As Integer
If a >= b Then intmax = a Else intmax = b
End Function
Function intmin (ByVal a As Integer, ByVal b As Integer) As Integer
If a <= b Then intmin = a Else intmin = b
End Function
Sub LoadMenuOptions ()
If UCase$(GetINI("Display", "FixedPitch", "N")) = "N" Then
frmmain.mnufixedpitch.Checked = False
Else
frmmain.mnufixedpitch.Checked = True
End If
If UCase$(GetINI("Display", "ShowHeaders", "N")) = "N" Then
frmmain.mnushowheaders.Checked = False
Else
frmmain.mnushowheaders.Checked = True
End If
If UCase$(GetINI("Display", "ShowLengths", "N")) = "N" Then
frmmain.mnushowlengths.Checked = False
Else
frmmain.mnushowlengths.Checked = True
End If
End Sub
Sub Main ()
Dim lpstr As Long
Dim result As Integer
Dim hold As String * 100
PaperboyVersion = "2.06"
' Go to Paperboy's EXE directory
ChDir app.Path
ChDrive app.Path
If app.PrevInstance = True Then
MsgBox "Only one Paperboy can be active.", MB_ICONSTOP, "Sorry"
End
End If
' Fire up the DLL
result = InitSOUPDLL()
If result <> 0 Then
MsgBox "Cannot initialize PBOYSOUP.DLL", MB_ICONEXCLAMATION, "InitSOUPDLL()"
End
End If
INIfile = "PAPERBOY.INI"
'INIfile = App.Path + "\PAPERBOY.INI"
SetINI "Paperboy", "Copyright", "(C) 1995, Michael H. Vartanian (vart@clark.net)"
SetINI "Paperboy", "License", "Paperboy is protected by the GNU public license, see the file COPYING included with Paperboy"
'Check Version
If MajorVersion() <> 2 Or MinorVersion() <> 6 Then
MsgBox "Wrong version of PBOYSOUP.DLL", MB_ICONSTOP, "Installation Error"
End
End If
If GetINI("Window", "Maximized", "N") = "N" Then
frmmain.WindowState = NORMAL
Else
frmmain.WindowState = MAXIMIZED
End If
Call LoadMenuOptions
frmmain.Height = Val(GetINI("Window", "Height", screen.Height * .9))
frmmain.Width = Val(GetINI("Window", "Width", screen.Width * .9))
frmmain.Left = Val(GetINI("Window", "Left", (screen.Width - frmmain.Width) \ 2))
frmmain.Top = Val(GetINI("Window", "Top", (screen.Height - frmmain.Height) \ 2))
frmmain!lstareas.FontName = GetINI("Fonts", "GroupsName", "Arial")
frmmain!lstareas.FontSize = Val(GetINI("Fonts", "GroupsSize", "10"))
frmmain!lstsubjects.FontName = GetINI("Fonts", "SubjName", "Arial")
frmmain!lstsubjects.FontSize = Val(GetINI("Fonts", "SubjSize", "10"))
' Handle Folders
Call DoFolders
' If command-line, assume it's the AREAS filename
If Len(Command$) > 1 Then
OpenAreas (Command$)
End If
If FileExists("REPLIES") Then
MsgBox "Don't forget to upload your replies packet." + Chr(13) + Chr(10) + "(pkzip UPLOADME.ZIP REPLIES. PB*.MSG)", MB_OK + MB_ICONINFORMATION, "REPLIES file found!"
End If
frmmain.Show Modal
' frmmain has quit, shut down
SetINI "Files", "LastGroupRead", Format$(Group)
SetINI "Files", "LastMessageRead", Format$(Message)
End
End Sub
Sub OpenAreas (filename As String)
Dim result, continue, count As Integer
Dim workdir As String
Dim unzip As String
Dim x As Integer
frmmain.mnuFOPEN.Enabled = False
screen.MousePointer = HourGlass
If UCase$(Right$(filename, 3)) = "ZIP" Then
' We got a ZIP packet to deal with
workdir = GetINI("Files", "Packet Directory", app.Path)
unzip = GetINI("Files", "Unzipper", "pkunzip -o -ere")
unzip = unzip + " " + filename + " " + workdir
'ChDrive workdir
'ChDir workdir
x = Shell(unzip, 6)
MsgBox "Press when complete...", 0, unzip
filename = workdir + "\AREAS."
If Not FileExists(filename) Then
frmmain.mnuFOPEN.Enabled = True
MsgBox "Couldn't extract packet", 0, "Error during unzip"
screen.MousePointer = default
Exit Sub
End If
End If
result = LoadAreas(filename)
screen.MousePointer = default
DllErr result
If GetInfo() = 0 Then
' We got something urgent to show
frminfo.Show 1
End If
Call ShowAreas
End Sub
Sub SaveFiletoFolder (fname As String, folder As String)
Dim foldernum As Integer
Dim folderfile As String
Dim foldername As String
Dim filenum As Integer
Dim textline As String
Dim result As Integer
folderfile = ""
For foldernum = 1 To NUMFOLDERS
foldername = GetINI("Folders", "Name" + Format$(foldernum), "")
If foldername = folder Then
folderfile = app.Path + "\FOLDER" + Format$(foldernum) + ".FOL"
End If
Next foldernum
If folderfile <> "" Then
' Save file fname to folder folderfile
Call CreateNewMsg
filenum = FreeFile
Open fname For Input As filenum
While Not EOF(filenum)
Line Input #filenum, textline
result = AddLineToMsg(textline)
Wend
Close filenum
result = SaveMsgToFolder(folderfile)
DllErr result
'MsgBox "Saved to " + folderfile
End If
' Reread folders
DoFolders
End Sub
Sub SetINI (ByVal section As String, ByVal key As String, ByVal value As String)
'Sets an INI attribute
Dim result As Integer
INIfile = "PAPERBOY.INI"
While Left$(value, 1) = " "
value = Mid$(value, 2) 'Remove trailing spaces
Wend
result = WritePrivateProfileString(section, key, value, INIfile)
End Sub
Sub ShowAreas ()
Dim count As Integer
Dim groupname As String
Dim hold, grp, msg As Integer
frmmain.lstareas.Clear
frmmain.lstsubjects.Clear
For count = 1 To GetNumAreas()
groupname = fixstr(GetAreaName(count))
frmmain.lstareas.AddItem groupname
Next count
frmmain.lstareas.Enabled = True
grp = Val(GetINI("Files", "LastGroupRead", "0")) - 1
msg = Val(GetINI("Files", "LastMessageRead", "0")) - 1
If Persist = True Then
Persist = False
hold = MsgBox("Should I put you at the last read message?", MB_ICONQUESTION Or MB_YESNO, "Previously viewed packet")
If hold = IDYES Then
If grp >= 0 Then frmmain.lstareas.ListIndex = grp
If msg >= 0 Then frmmain.lstsubjects.ListIndex = msg
End If
End If
End Sub
Function stripfilename (filename As String) As String
Dim lastbackslash, p As Integer
For p = 1 To Len(filename)
If Mid$(filename, p, 1) = "\" Then lastbackslash = p
Next p
If lastbackslash > 1 Then
stripfilename = Left$(filename, lastbackslash - 1)
Else
stripfilename = "\"
End If
End Function